home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Thomas / run-collections-generic1.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  14.1 KB  |  425 lines  |  [TEXT/gamI]
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;*
  20. ;*            Director, Cambridge Research Lab
  21. ;*            Digital Equipment Corp
  22. ;*            One Kendall Square, Bldg 700
  23. ;*            Cambridge MA 02139
  24. ;*
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.
  28. ;*
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: runtime-collections-generic1.scm,v 1.30 1992/09/18 23:46:36 birkholz Exp $
  39.  
  40. ;;; This file contains the implementation of most of the generic functions
  41. ;;; and methods that deal with collections and their subtypes.  The
  42. ;;; organization follows the Dylan manual.  The specializations of method
  43. ;;; based on collection type are in the file: runtime-collections-xxx.scm
  44. ;;; (where xxx is collection type)
  45.  
  46. ;;;;
  47. ;;;; Misc. functions
  48. ;;;;
  49.  
  50. (add-method dylan:binary=
  51.   (dylan::function->method
  52.     two-collections
  53.     (lambda (coll-1 coll-2)
  54.       (let ((key-sequence-1 (dylan-call dylan:key-sequence coll-1))
  55.         (key-sequence-2 (dylan-call dylan:key-sequence coll-2))
  56.         (size-1 (dylan-call dylan:size coll-1))
  57.         (size-2 (dylan-call dylan:size coll-2)))
  58.     (cond ((not (and size-1 size-2)) #F)
  59.           ; if either one is unbound, then false, since specific methods
  60.           ; will handle infinite ranges and circular lists
  61.           ((not (= size-1 size-2)) #F)
  62.           (else
  63.            (let loop ((state
  64.                (dylan-call dylan:initial-state key-sequence-1)))
  65.          (if (not state)
  66.              #T
  67.              (let ((key (dylan-call
  68.                  dylan:current-element key-sequence-1 state)))
  69.                (if (dylan-call dylan:member? key key-sequence-2
  70.                        'test:
  71.                        (make-dylan-callable
  72.                     (lambda (a b)
  73.                       (dylan-call dylan:= a b))))
  74.                (if (dylan-call
  75.                 dylan:=
  76.                 (dylan-call dylan:element coll-1 key)
  77.                 (dylan-call dylan:element coll-2 key))
  78.                    (loop
  79.                 (dylan-call dylan:next-state key-sequence-1
  80.                         state))
  81.                    #F)
  82.                #F))))))))))
  83.  
  84.  
  85.  
  86. (add-method dylan:binary=
  87.   (dylan::function->method
  88.    two-sequences
  89.    (lambda (seq-1 seq-2)
  90.      (let ((size-1 (dylan-call dylan:size seq-1))
  91.        (size-2 (dylan-call dylan:size seq-2)))
  92.        (cond ((not (and size-1 size-2)) #F)
  93.          ; if either one is unbound, then false, since specific methods
  94.          ; will handle infinite ranges and circular lists
  95.          ((not (= size-1 size-2)) #F)
  96.          (else
  97.           (do ((state-1 (dylan-call dylan:initial-state seq-1)
  98.                 (dylan-call dylan:next-state seq-1 state-1))
  99.            (state-2 (dylan-call dylan:initial-state seq-2)
  100.                 (dylan-call dylan:next-state seq-2 state-2)))
  101.           ((or (or (not state-1) (not state-2))
  102.                (not (dylan-call dylan:id?
  103.                     (dylan-call dylan:current-element
  104.                             seq-1 state-1)
  105.                     (dylan-call dylan:current-element
  106.                             seq-2 state-2))))
  107.            (if (or state-1 state-2) #F #T)))))))))
  108.  
  109. (add-method dylan:shallow-copy
  110.   (dylan::function->method
  111.     (make-param-list `((COLLECTION ,<collection>)) #F #F #F)
  112.     (lambda (coll)
  113.       (dylan-call dylan:error
  114.           "shallow-copy -- not specialized for this collection type"
  115.           coll))))
  116.  
  117. (add-method dylan:shallow-copy
  118.   (dylan::function->method
  119.     (make-param-list `((SEQUENCE ,<sequence>)) #F #F #F)
  120.     (lambda (seq)
  121.       (dylan-call dylan:copy-sequence seq))))
  122.  
  123. (add-method dylan:as
  124.   ;; This requires specialization of AS for classes that are not
  125.   ;; superclasses of list (such as array, table, ...)
  126.   (dylan::function->method
  127.    (make-param-list `((CLASS ,(dylan::make-singleton <collection>))
  128.               (COLLECTION ,<collection>)) #F #F #F)
  129.     (lambda (class collection)
  130.       class
  131.       (dylan-call dylan:as <list> collection))))
  132.  
  133. (add-method dylan:as
  134.   (dylan::function->method
  135.    (make-param-list `((CLASS ,(dylan::make-singleton <explicit-key-collection>))
  136.               (COLLECTION ,<collection>)) #F #F #F)
  137.     (lambda (class collection)
  138.       class
  139.       (dylan-call dylan:as <vector> collection))))
  140.  
  141. ;;;;
  142. ;;;; FUNCTIONS FOR COLLECTIONS (page 99)
  143. ;;;;
  144.  
  145. (define dylan:size
  146.   (dylan::generic-fn 'size
  147.     one-collection
  148.     (lambda (collection)
  149.       (let ((index 0))
  150.     (iterate-until (lambda (elem)
  151.              elem (set! index (+ index 1)) #F)
  152.                collection)
  153.     index))))
  154.  
  155.  
  156. (define dylan:class-for-copy
  157.   (dylan::generic-fn 'class-for-copy one-object
  158.      (lambda (x) (dylan-call dylan:object-class x))))
  159.  
  160. (define dylan:empty?
  161.   (dylan::generic-fn 'empty?
  162.    (make-param-list `((COLLECTION ,<collection>)) #F #F #F)
  163.    (lambda (collection)
  164.      (if (dylan-call dylan:initial-state collection)
  165.      #F
  166.      #T))))
  167.  
  168. (define dylan:do
  169.   (dylan::generic-fn 'do
  170.    (make-param-list
  171.     `((FUNCTION ,<function>) (COLLECTION ,<collection>)) #F #T #F)
  172.    (lambda (fn . collections)
  173.      (collections-iterate fn (lambda (val)
  174.                    val        ; Ignored
  175.                    #F)
  176.               #F
  177.               collections))))
  178.  
  179. (define dylan:map
  180.   (dylan::generic-fn 'map
  181.      procedure-and-at-least-one-collection
  182.      (lambda (proc li . rest)
  183.        (let ((all-lists (cons li rest)))
  184.      (let loop ((result '())
  185.             (next-states (map (lambda (li)
  186.                     (dylan-call dylan:initial-state li))
  187.                       all-lists)))
  188.        (if (any? (lambda (state) (not state)) next-states)
  189.            (dylan-call dylan:as
  190.                (dylan-call dylan:class-for-copy li)
  191.                (reverse result))
  192.            (let ((next-value
  193.               (dylan-call dylan:apply
  194.                   proc (map (lambda (li st)
  195.                           (dylan-call dylan:current-element
  196.                               li st))
  197.                         all-lists next-states))))
  198.          (loop (cons next-value result)
  199.                (map (lambda (li st)
  200.                   (dylan-call dylan:next-state li st))
  201.                 all-lists next-states)))))))))
  202.  
  203. (define dylan:map-as
  204.   (dylan::generic-fn 'map-as
  205.     (make-param-list `((CLASS ,<class>)
  206.                (PROC ,<function>)
  207.                (COLLECTION ,<collection>))
  208.              #F #T #F)
  209.     (lambda (class proc collection . rest)
  210.       (let ((result (dylan-call dylan:apply
  211.                 dylan:map
  212.                 (cons proc
  213.                       (cons collection rest)))))
  214.     (dylan-call dylan:as class result)))))
  215.  
  216.  
  217. (define dylan:map-into
  218.   (dylan::generic-fn 'map-into
  219.     (make-param-list `((MUTABLE-COLLECTION ,<mutable-collection>)
  220.                (PROCEDURE ,<function>)
  221.                (COLLECTION ,<collection>))
  222.               #F #T #F)
  223.      (lambda (mut-coll proc coll-1 . rest)
  224.        (let ((current-state (dylan-call dylan:initial-state mut-coll)))
  225.      (collections-iterate
  226.       proc
  227.       (lambda (new-value)
  228.         (dylan-call dylan:setter/current-element/ mut-coll
  229.             current-state new-value)
  230.         (set! current-state
  231.           (dylan-call dylan:next-state mut-coll current-state))
  232.         #F)
  233.       mut-coll
  234.       `(,mut-coll ,coll-1 ,@rest))))))
  235.  
  236. (define dylan:any?
  237.   (dylan::generic-fn 'any?
  238.     (make-param-list
  239.      `((PROCEDURE ,<function>) (COLLECTION ,<collection>)) #F #T #F)
  240.     (lambda (fn . collections)
  241.       (collections-iterate fn
  242.                (lambda (val) (if val (lambda () val) #F))
  243.                #F
  244.                collections))))
  245.  
  246. (define dylan:every?
  247.   (dylan::generic-fn 'every?
  248.     (make-param-list `((PROCEDURE ,<function>)
  249.                (COLLECTION ,<collection>))
  250.              #F #T #F)
  251.     (lambda (fn . collections)
  252.       (collections-iterate fn
  253.                (lambda (val) (if val #F (lambda () #F)))
  254.                #T
  255.                collections))))
  256.  
  257. (define dylan:reduce
  258.   (dylan::generic-fn 'reduce
  259.     (make-param-list `((PROCEDURE ,<function>)
  260.                (INIT-VALUE ,<object>)
  261.                (COLLECTION ,<collection>))
  262.              #F #F #F)
  263.     (lambda (proc init-value collection)
  264.       (if (dylan-call dylan:empty? collection)
  265.       init-value
  266.       (let loop ((cur-value init-value)
  267.              (state (dylan-call dylan:initial-state collection)))
  268.         (if state
  269.         (let ((next-value (dylan-call proc
  270.                           cur-value
  271.                           (dylan-call dylan:current-element
  272.                               collection state))))
  273.           (loop next-value (dylan-call dylan:next-state
  274.                            collection state)))
  275.         cur-value))))))
  276.  
  277. (define dylan:reduce1
  278.   (dylan::generic-fn 'reduce1
  279.     (make-param-list `((PROCEDURE ,<function>)
  280.                (COLLECTION ,<collection>)) #F #F #F)
  281.     (lambda (proc collection)
  282.       (if (dylan-call dylan:empty? collection)
  283.       (dylan-call dylan:error
  284.               "reduce1 -- collection argument is empty" proc collection)
  285.       (let loop ((cur-value
  286.               (dylan-call dylan:current-element
  287.                   collection
  288.                   (dylan-call dylan:initial-state collection)))
  289.              (state
  290.               (dylan-call dylan:next-state
  291.                   collection
  292.                   (dylan-call dylan:initial-state collection))))
  293.         (if state
  294.         (let ((next-value (dylan-call proc
  295.                           cur-value
  296.                           (dylan-call dylan:current-element
  297.                               collection state))))
  298.           (loop next-value (dylan-call dylan:next-state
  299.                            collection state)))
  300.         cur-value))))))
  301.  
  302.  
  303. (define dylan:member?
  304.   (dylan::generic-fn
  305.    'member?
  306.    (make-param-list `((VALUE ,<object>) (COLLECTION ,<collection>))
  307.             #F #F '(test:))
  308.    #F))
  309.  
  310. (add-method
  311.  dylan:member?
  312.  (dylan::dylan-callable->method
  313.   (make-param-list `((VALUE ,<object>) (COLLECTION ,<collection>))
  314.            #F #F '(test:))
  315.   (lambda (multiple-values next-method value collection . keys)
  316.     multiple-values
  317.     (dylan::keyword-validate next-method keys '(test:))
  318.     (let ((test (dylan::find-keyword keys 'test: (lambda () dylan:id?))))
  319.       (call-with-current-continuation
  320.        (lambda (return-value)
  321.      (iterate!
  322.       (lambda (obj)
  323.         (let ((test-value (dylan-call test value obj)))
  324.           (if test-value (return-value test-value))))
  325.       collection)
  326.      (return-value #F)))))))
  327.  
  328. (define dylan:find-key
  329.   (dylan::generic-fn
  330.    'find-key
  331.    (make-param-list `((COLLECTION ,<collection>) (PREDICATE ,<function>))
  332.             #F #F '(skip: failure:))
  333.    #F))
  334.  
  335. (add-method
  336.  dylan:find-key
  337.  (dylan::dylan-callable->method
  338.   (make-param-list `((COLLECTION ,<collection>) (PREDICATE ,<function>))
  339.            #F #F '(skip: failure:))
  340.   (lambda (multiple-values next-method collection predicate . rest)
  341.     multiple-values
  342.     (dylan::keyword-validate next-method rest '(skip: failure:))
  343.     (let ((skip (dylan::find-keyword rest 'skip: (lambda () 0)))
  344.       (failure (dylan::find-keyword rest 'failure: (lambda () #F)))
  345.       (key-sequence (dylan-call dylan:key-sequence collection)))
  346.       (let loop ((key-state (dylan-call dylan:initial-state key-sequence))
  347.          (satisfied 0))
  348.     (cond ((not key-state) failure)
  349.           ((dylan-call predicate
  350.                (dylan-call dylan:element
  351.                        collection
  352.                        (dylan-call dylan:current-element
  353.                            key-sequence key-state)))
  354.            (if (> satisfied (- skip 1))
  355.            (dylan-call dylan:current-element key-sequence key-state)
  356.            (loop (dylan-call dylan:next-state key-sequence key-state)
  357.              (+ satisfied 1))))
  358.           (else (loop (dylan-call dylan:next-state key-sequence key-state)
  359.               satisfied))))))))
  360.  
  361. (define dylan:replace-elements!
  362.   (dylan::generic-fn
  363.    'replace-elements!
  364.    (make-param-list `((COLLECTION ,<mutable-collection>)
  365.               (PREDICATE ,<function>)
  366.               (NEW-VAL-FN ,<function>))
  367.             #F #F '(count:))
  368.    #F))
  369.  
  370. (add-method
  371.  dylan:replace-elements!
  372.  (dylan::dylan-callable->method
  373.   (make-param-list `((COLLECTION ,<mutable-collection>)
  374.              (PREDICATE ,<function>)
  375.              (NEW-VAL-FN ,<function>))
  376.            #F #F '(count:))
  377.   (lambda (multiple-values next-method coll predicate new-val-fn . rest)
  378.     multiple-values
  379.     (dylan::keyword-validate next-method rest '(count:))
  380.     (let* ((size (dylan-call dylan:size coll))
  381.        (count (dylan::find-keyword rest 'count: (lambda () size))))
  382.       (let loop ((state (dylan-call dylan:initial-state coll))
  383.          (num-changed 0))
  384.     (cond ((or (>= num-changed count) (not state)) coll)
  385.           ((dylan-call predicate
  386.                (dylan-call dylan:current-element coll state))
  387.            (dylan-call
  388.         dylan:setter/current-element/
  389.         coll state (dylan-call new-val-fn
  390.                        (dylan-call dylan:current-element
  391.                            coll state)))
  392.            (loop (dylan-call dylan:next-state coll state)
  393.              (+ num-changed 1)))
  394.           (else (loop (dylan-call dylan:next-state coll state)
  395.               num-changed))))))))
  396.  
  397.  
  398. (define dylan:fill!
  399.   (dylan::generic-fn
  400.    'fill!
  401.    (make-param-list `((MUTABLE-COLLECTION ,<mutable-collection>)
  402.               (VALUE ,<object>))
  403.             #F #F '(start: end:))
  404.    #F))
  405.  
  406. (add-method
  407.  dylan:fill!
  408.  (dylan::dylan-callable->method
  409.   (make-param-list `((MUTABLE-COLLECTION ,<mutable-collection>)
  410.              (VALUE ,<object>))
  411.            #F #F '(start: end:))
  412.   (lambda (multiple-values next-method collection new-value . rest)
  413.     multiple-values
  414.     (dylan::keyword-validate next-method rest '(start: end:))
  415.     (let ((start (dylan::find-keyword rest 'start: (lambda () 0)))
  416.       (end (dylan::find-keyword
  417.         rest 'end: (lambda () (dylan-call dylan:size collection)))))
  418.       (do ((state (dylan-call dylan:initial-state collection)
  419.           (dylan-call dylan:next-state collection state))
  420.        (index 0 (+ index 1)))
  421.       ((or (not state) (>= index end)) collection)
  422.     (if (and state (>= index start))
  423.         (dylan-call dylan:setter/current-element/
  424.             collection state new-value)))))))
  425.